home *** CD-ROM | disk | FTP | other *** search
/ Stone Design / Stone Design.iso / Stone_Friends / Wave / WavesWorld / Source / Libraries / tcl7.4b3 / tclCmdAH.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-01-10  |  22.5 KB  |  948 lines
  1. /* 
  2.  * tclCmdAH.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    A to H.
  7.  *
  8.  * Copyright (c) 1987-1993 The Regents of the University of California.
  9.  * Copyright (c) 1994 Sun Microsystems, Inc.
  10.  *
  11.  * See the file "license.terms" for information on usage and redistribution
  12.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13.  */
  14.  
  15. #ifndef lint
  16. static char sccsid[] = "@(#) tclCmdAH.c 1.97 95/01/10 09:26:57";
  17. #endif
  18.  
  19. #include "tclInt.h"
  20. #include "tclPort.h"
  21.  
  22.  
  23. /*
  24.  *----------------------------------------------------------------------
  25.  *
  26.  * Tcl_BreakCmd --
  27.  *
  28.  *    This procedure is invoked to process the "break" Tcl command.
  29.  *    See the user documentation for details on what it does.
  30.  *
  31.  * Results:
  32.  *    A standard Tcl result.
  33.  *
  34.  * Side effects:
  35.  *    See the user documentation.
  36.  *
  37.  *----------------------------------------------------------------------
  38.  */
  39.  
  40.     /* ARGSUSED */
  41. int
  42. Tcl_BreakCmd(dummy, interp, argc, argv)
  43.     ClientData dummy;            /* Not used. */
  44.     Tcl_Interp *interp;            /* Current interpreter. */
  45.     int argc;                /* Number of arguments. */
  46.     char **argv;            /* Argument strings. */
  47. {
  48.     if (argc != 1) {
  49.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  50.         argv[0], "\"", (char *) NULL);
  51.     return TCL_ERROR;
  52.     }
  53.     return TCL_BREAK;
  54. }
  55.  
  56. /*
  57.  *----------------------------------------------------------------------
  58.  *
  59.  * Tcl_CaseCmd --
  60.  *
  61.  *    This procedure is invoked to process the "case" Tcl command.
  62.  *    See the user documentation for details on what it does.
  63.  *
  64.  * Results:
  65.  *    A standard Tcl result.
  66.  *
  67.  * Side effects:
  68.  *    See the user documentation.
  69.  *
  70.  *----------------------------------------------------------------------
  71.  */
  72.  
  73.     /* ARGSUSED */
  74. int
  75. Tcl_CaseCmd(dummy, interp, argc, argv)
  76.     ClientData dummy;            /* Not used. */
  77.     Tcl_Interp *interp;            /* Current interpreter. */
  78.     int argc;                /* Number of arguments. */
  79.     char **argv;            /* Argument strings. */
  80. {
  81.     int i, result;
  82.     int body;
  83.     char *string;
  84.     int caseArgc, splitArgs;
  85.     char **caseArgv;
  86.  
  87.     if (argc < 3) {
  88.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  89.         argv[0], " string ?in? patList body ... ?default body?\"",
  90.         (char *) NULL);
  91.     return TCL_ERROR;
  92.     }
  93.     string = argv[1];
  94.     body = -1;
  95.     if (strcmp(argv[2], "in") == 0) {
  96.     i = 3;
  97.     } else {
  98.     i = 2;
  99.     }
  100.     caseArgc = argc - i;
  101.     caseArgv = argv + i;
  102.  
  103.     /*
  104.      * If all of the pattern/command pairs are lumped into a single
  105.      * argument, split them out again.
  106.      */
  107.  
  108.     splitArgs = 0;
  109.     if (caseArgc == 1) {
  110.     result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv);
  111.     if (result != TCL_OK) {
  112.         return result;
  113.     }
  114.     splitArgs = 1;
  115.     }
  116.  
  117.     for (i = 0; i < caseArgc; i += 2) {
  118.     int patArgc, j;
  119.     char **patArgv;
  120.     register char *p;
  121.  
  122.     if (i == (caseArgc-1)) {
  123.         interp->result = "extra case pattern with no body";
  124.         result = TCL_ERROR;
  125.         goto cleanup;
  126.     }
  127.  
  128.     /*
  129.      * Check for special case of single pattern (no list) with
  130.      * no backslash sequences.
  131.      */
  132.  
  133.     for (p = caseArgv[i]; *p != 0; p++) {
  134.         if (isspace(UCHAR(*p)) || (*p == '\\')) {
  135.         break;
  136.         }
  137.     }
  138.     if (*p == 0) {
  139.         if ((*caseArgv[i] == 'd')
  140.             && (strcmp(caseArgv[i], "default") == 0)) {
  141.         body = i+1;
  142.         }
  143.         if (Tcl_StringMatch(string, caseArgv[i])) {
  144.         body = i+1;
  145.         goto match;
  146.         }
  147.         continue;
  148.     }
  149.  
  150.     /*
  151.      * Break up pattern lists, then check each of the patterns
  152.      * in the list.
  153.      */
  154.  
  155.     result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv);
  156.     if (result != TCL_OK) {
  157.         goto cleanup;
  158.     }
  159.     for (j = 0; j < patArgc; j++) {
  160.         if (Tcl_StringMatch(string, patArgv[j])) {
  161.         body = i+1;
  162.         break;
  163.         }
  164.     }
  165.     ckfree((char *) patArgv);
  166.     if (j < patArgc) {
  167.         break;
  168.     }
  169.     }
  170.  
  171.     match:
  172.     if (body != -1) {
  173.     result = Tcl_Eval(interp, caseArgv[body]);
  174.     if (result == TCL_ERROR) {
  175.         char msg[100];
  176.         sprintf(msg, "\n    (\"%.50s\" arm line %d)", caseArgv[body-1],
  177.             interp->errorLine);
  178.         Tcl_AddErrorInfo(interp, msg);
  179.     }
  180.     goto cleanup;
  181.     }
  182.  
  183.     /*
  184.      * Nothing matched:  return nothing.
  185.      */
  186.  
  187.     result = TCL_OK;
  188.  
  189.     cleanup:
  190.     if (splitArgs) {
  191.     ckfree((char *) caseArgv);
  192.     }
  193.     return result;
  194. }
  195.  
  196. /*
  197.  *----------------------------------------------------------------------
  198.  *
  199.  * Tcl_CatchCmd --
  200.  *
  201.  *    This procedure is invoked to process the "catch" Tcl command.
  202.  *    See the user documentation for details on what it does.
  203.  *
  204.  * Results:
  205.  *    A standard Tcl result.
  206.  *
  207.  * Side effects:
  208.  *    See the user documentation.
  209.  *
  210.  *----------------------------------------------------------------------
  211.  */
  212.  
  213.     /* ARGSUSED */
  214. int
  215. Tcl_CatchCmd(dummy, interp, argc, argv)
  216.     ClientData dummy;            /* Not used. */
  217.     Tcl_Interp *interp;            /* Current interpreter. */
  218.     int argc;                /* Number of arguments. */
  219.     char **argv;            /* Argument strings. */
  220. {
  221.     int result;
  222.  
  223.     if ((argc != 2) && (argc != 3)) {
  224.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  225.         argv[0], " command ?varName?\"", (char *) NULL);
  226.     return TCL_ERROR;
  227.     }
  228.     result = Tcl_Eval(interp, argv[1]);
  229.     if (argc == 3) {
  230.     if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) {
  231.         Tcl_SetResult(interp, "couldn't save command result in variable",
  232.             TCL_STATIC);
  233.         return TCL_ERROR;
  234.     }
  235.     }
  236.     Tcl_ResetResult(interp);
  237.     sprintf(interp->result, "%d", result);
  238.     return TCL_OK;
  239. }
  240.  
  241. /*
  242.  *----------------------------------------------------------------------
  243.  *
  244.  * Tcl_ConcatCmd --
  245.  *
  246.  *    This procedure is invoked to process the "concat" Tcl command.
  247.  *    See the user documentation for details on what it does.
  248.  *
  249.  * Results:
  250.  *    A standard Tcl result.
  251.  *
  252.  * Side effects:
  253.  *    See the user documentation.
  254.  *
  255.  *----------------------------------------------------------------------
  256.  */
  257.  
  258.     /* ARGSUSED */
  259. int
  260. Tcl_ConcatCmd(dummy, interp, argc, argv)
  261.     ClientData dummy;            /* Not used. */
  262.     Tcl_Interp *interp;            /* Current interpreter. */
  263.     int argc;                /* Number of arguments. */
  264.     char **argv;            /* Argument strings. */
  265. {
  266.     if (argc >= 2) {
  267.     interp->result = Tcl_Concat(argc-1, argv+1);
  268.     interp->freeProc = (Tcl_FreeProc *) free;
  269.     }
  270.     return TCL_OK;
  271. }
  272.  
  273. /*
  274.  *----------------------------------------------------------------------
  275.  *
  276.  * Tcl_ContinueCmd --
  277.  *
  278.  *    This procedure is invoked to process the "continue" Tcl command.
  279.  *    See the user documentation for details on what it does.
  280.  *
  281.  * Results:
  282.  *    A standard Tcl result.
  283.  *
  284.  * Side effects:
  285.  *    See the user documentation.
  286.  *
  287.  *----------------------------------------------------------------------
  288.  */
  289.  
  290.     /* ARGSUSED */
  291. int
  292. Tcl_ContinueCmd(dummy, interp, argc, argv)
  293.     ClientData dummy;            /* Not used. */
  294.     Tcl_Interp *interp;            /* Current interpreter. */
  295.     int argc;                /* Number of arguments. */
  296.     char **argv;            /* Argument strings. */
  297. {
  298.     if (argc != 1) {
  299.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  300.         "\"", (char *) NULL);
  301.     return TCL_ERROR;
  302.     }
  303.     return TCL_CONTINUE;
  304. }
  305.  
  306. /*
  307.  *----------------------------------------------------------------------
  308.  *
  309.  * Tcl_ErrorCmd --
  310.  *
  311.  *    This procedure is invoked to process the "error" Tcl command.
  312.  *    See the user documentation for details on what it does.
  313.  *
  314.  * Results:
  315.  *    A standard Tcl result.
  316.  *
  317.  * Side effects:
  318.  *    See the user documentation.
  319.  *
  320.  *----------------------------------------------------------------------
  321.  */
  322.  
  323.     /* ARGSUSED */
  324. int
  325. Tcl_ErrorCmd(dummy, interp, argc, argv)
  326.     ClientData dummy;            /* Not used. */
  327.     Tcl_Interp *interp;            /* Current interpreter. */
  328.     int argc;                /* Number of arguments. */
  329.     char **argv;            /* Argument strings. */
  330. {
  331.     Interp *iPtr = (Interp *) interp;
  332.  
  333.     if ((argc < 2) || (argc > 4)) {
  334.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  335.         " message ?errorInfo? ?errorCode?\"", (char *) NULL);
  336.     return TCL_ERROR;
  337.     }
  338.     if ((argc >= 3) && (argv[2][0] != 0)) {
  339.     Tcl_AddErrorInfo(interp, argv[2]);
  340.     iPtr->flags |= ERR_ALREADY_LOGGED;
  341.     }
  342.     if (argc == 4) {
  343.     Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3],
  344.         TCL_GLOBAL_ONLY);
  345.     iPtr->flags |= ERROR_CODE_SET;
  346.     }
  347.     Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
  348.     return TCL_ERROR;
  349. }
  350.  
  351. /*
  352.  *----------------------------------------------------------------------
  353.  *
  354.  * Tcl_EvalCmd --
  355.  *
  356.  *    This procedure is invoked to process the "eval" Tcl command.
  357.  *    See the user documentation for details on what it does.
  358.  *
  359.  * Results:
  360.  *    A standard Tcl result.
  361.  *
  362.  * Side effects:
  363.  *    See the user documentation.
  364.  *
  365.  *----------------------------------------------------------------------
  366.  */
  367.  
  368.     /* ARGSUSED */
  369. int
  370. Tcl_EvalCmd(dummy, interp, argc, argv)
  371.     ClientData dummy;            /* Not used. */
  372.     Tcl_Interp *interp;            /* Current interpreter. */
  373.     int argc;                /* Number of arguments. */
  374.     char **argv;            /* Argument strings. */
  375. {
  376.     int result;
  377.     char *cmd;
  378.  
  379.     if (argc < 2) {
  380.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  381.         " arg ?arg ...?\"", (char *) NULL);
  382.     return TCL_ERROR;
  383.     }
  384.     if (argc == 2) {
  385.     result = Tcl_Eval(interp, argv[1]);
  386.     } else {
  387.     
  388.     /*
  389.      * More than one argument:  concatenate them together with spaces
  390.      * between, then evaluate the result.
  391.      */
  392.     
  393.     cmd = Tcl_Concat(argc-1, argv+1);
  394.     result = Tcl_Eval(interp, cmd);
  395.     ckfree(cmd);
  396.     }
  397.     if (result == TCL_ERROR) {
  398.     char msg[60];
  399.     sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
  400.     Tcl_AddErrorInfo(interp, msg);
  401.     }
  402.     return result;
  403. }
  404.  
  405. /*
  406.  *----------------------------------------------------------------------
  407.  *
  408.  * Tcl_ExprCmd --
  409.  *
  410.  *    This procedure is invoked to process the "expr" Tcl command.
  411.  *    See the user documentation for details on what it does.
  412.  *
  413.  * Results:
  414.  *    A standard Tcl result.
  415.  *
  416.  * Side effects:
  417.  *    See the user documentation.
  418.  *
  419.  *----------------------------------------------------------------------
  420.  */
  421.  
  422.     /* ARGSUSED */
  423. int
  424. Tcl_ExprCmd(dummy, interp, argc, argv)
  425.     ClientData dummy;            /* Not used. */
  426.     Tcl_Interp *interp;            /* Current interpreter. */
  427.     int argc;                /* Number of arguments. */
  428.     char **argv;            /* Argument strings. */
  429. {
  430.     Tcl_DString buffer;
  431.     int i, result;
  432.  
  433.     if (argc < 2) {
  434.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  435.         " arg ?arg ...?\"", (char *) NULL);
  436.     return TCL_ERROR;
  437.     }
  438.  
  439.     if (argc == 2) {
  440.     return Tcl_ExprString(interp, argv[1]);
  441.     }
  442.     Tcl_DStringInit(&buffer);
  443.     Tcl_DStringAppend(&buffer, argv[1], -1);
  444.     for (i = 2; i < argc; i++) {
  445.     Tcl_DStringAppend(&buffer, " ", 1);
  446.     Tcl_DStringAppend(&buffer, argv[i], -1);
  447.     }
  448.     result = Tcl_ExprString(interp, buffer.string);
  449.     Tcl_DStringFree(&buffer);
  450.     return result;
  451. }
  452.  
  453. /*
  454.  *----------------------------------------------------------------------
  455.  *
  456.  * Tcl_ForCmd --
  457.  *
  458.  *    This procedure is invoked to process the "for" Tcl command.
  459.  *    See the user documentation for details on what it does.
  460.  *
  461.  * Results:
  462.  *    A standard Tcl result.
  463.  *
  464.  * Side effects:
  465.  *    See the user documentation.
  466.  *
  467.  *----------------------------------------------------------------------
  468.  */
  469.  
  470.     /* ARGSUSED */
  471. int
  472. Tcl_ForCmd(dummy, interp, argc, argv)
  473.     ClientData dummy;            /* Not used. */
  474.     Tcl_Interp *interp;            /* Current interpreter. */
  475.     int argc;                /* Number of arguments. */
  476.     char **argv;            /* Argument strings. */
  477. {
  478.     int result, value;
  479.  
  480.     if (argc != 5) {
  481.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  482.         " start test next command\"", (char *) NULL);
  483.     return TCL_ERROR;
  484.     }
  485.  
  486.     result = Tcl_Eval(interp, argv[1]);
  487.     if (result != TCL_OK) {
  488.     if (result == TCL_ERROR) {
  489.         Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
  490.     }
  491.     return result;
  492.     }
  493.     while (1) {
  494.     result = Tcl_ExprBoolean(interp, argv[2], &value);
  495.     if (result != TCL_OK) {
  496.         return result;
  497.     }
  498.     if (!value) {
  499.         break;
  500.     }
  501.     result = Tcl_Eval(interp, argv[4]);
  502.     if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
  503.         if (result == TCL_ERROR) {
  504.         char msg[60];
  505.         sprintf(msg, "\n    (\"for\" body line %d)", interp->errorLine);
  506.         Tcl_AddErrorInfo(interp, msg);
  507.         }
  508.         break;
  509.     }
  510.     result = Tcl_Eval(interp, argv[3]);
  511.     if (result == TCL_BREAK) {
  512.         break;
  513.     } else if (result != TCL_OK) {
  514.         if (result == TCL_ERROR) {
  515.         Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
  516.         }
  517.         return result;
  518.     }
  519.     }
  520.     if (result == TCL_BREAK) {
  521.     result = TCL_OK;
  522.     }
  523.     if (result == TCL_OK) {
  524.     Tcl_ResetResult(interp);
  525.     }
  526.     return result;
  527. }
  528.  
  529. /*
  530.  *----------------------------------------------------------------------
  531.  *
  532.  * Tcl_ForeachCmd --
  533.  *
  534.  *    This procedure is invoked to process the "foreach" Tcl command.
  535.  *    See the user documentation for details on what it does.
  536.  *
  537.  * Results:
  538.  *    A standard Tcl result.
  539.  *
  540.  * Side effects:
  541.  *    See the user documentation.
  542.  *
  543.  *----------------------------------------------------------------------
  544.  */
  545.  
  546.     /* ARGSUSED */
  547. int
  548. Tcl_ForeachCmd(dummy, interp, argc, argv)
  549.     ClientData dummy;            /* Not used. */
  550.     Tcl_Interp *interp;            /* Current interpreter. */
  551.     int argc;                /* Number of arguments. */
  552.     char **argv;            /* Argument strings. */
  553. {
  554.     int listArgc, i, result;
  555.     char **listArgv;
  556.  
  557.     if (argc != 4) {
  558.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  559.         " varName list command\"", (char *) NULL);
  560.     return TCL_ERROR;
  561.     }
  562.  
  563.     /*
  564.      * Break the list up into elements, and execute the command once
  565.      * for each value of the element.
  566.      */
  567.  
  568.     result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv);
  569.     if (result != TCL_OK) {
  570.     return result;
  571.     }
  572.     for (i = 0; i < listArgc; i++) {
  573.     if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == NULL) {
  574.         Tcl_SetResult(interp, "couldn't set loop variable", TCL_STATIC);
  575.         result = TCL_ERROR;
  576.         break;
  577.     }
  578.  
  579.     result = Tcl_Eval(interp, argv[3]);
  580.     if (result != TCL_OK) {
  581.         if (result == TCL_CONTINUE) {
  582.         result = TCL_OK;
  583.         } else if (result == TCL_BREAK) {
  584.         result = TCL_OK;
  585.         break;
  586.         } else if (result == TCL_ERROR) {
  587.         char msg[100];
  588.         sprintf(msg, "\n    (\"foreach\" body line %d)",
  589.             interp->errorLine);
  590.         Tcl_AddErrorInfo(interp, msg);
  591.         break;
  592.         } else {
  593.         break;
  594.         }
  595.     }
  596.     }
  597.     ckfree((char *) listArgv);
  598.     if (result == TCL_OK) {
  599.     Tcl_ResetResult(interp);
  600.     }
  601.     return result;
  602. }
  603.  
  604. /*
  605.  *----------------------------------------------------------------------
  606.  *
  607.  * Tcl_FormatCmd --
  608.  *
  609.  *    This procedure is invoked to process the "format" Tcl command.
  610.  *    See the user documentation for details on what it does.
  611.  *
  612.  * Results:
  613.  *    A standard Tcl result.
  614.  *
  615.  * Side effects:
  616.  *    See the user documentation.
  617.  *
  618.  *----------------------------------------------------------------------
  619.  */
  620.  
  621.     /* ARGSUSED */
  622. int
  623. Tcl_FormatCmd(dummy, interp, argc, argv)
  624.     ClientData dummy;            /* Not used. */
  625.     Tcl_Interp *interp;            /* Current interpreter. */
  626.     int argc;                /* Number of arguments. */
  627.     char **argv;            /* Argument strings. */
  628. {
  629.     register char *format;    /* Used to read characters from the format
  630.                  * string. */
  631.     char newFormat[40];        /* A new format specifier is generated here. */
  632.     int width;            /* Field width from field specifier, or 0 if
  633.                  * no width given. */
  634.     int precision;        /* Field precision from field specifier, or 0
  635.                  * if no precision given. */
  636.     int size;            /* Number of bytes needed for result of
  637.                  * conversion, based on type of conversion
  638.                  * ("e", "s", etc.) and width from above. */
  639.     int intValue;        /* Used to hold value to pass to sprintf, if
  640.                  * it's a one-word integer or char value */
  641.     char *ptrValue = NULL;    /* Used to hold value to pass to sprintf, if
  642.                  * it's a one-word value. */
  643.     double doubleValue;        /* Used to hold value to pass to sprintf if
  644.                  * it's a double value. */
  645.     int whichValue;        /* Indicates which of intValue, ptrValue,
  646.                  * or doubleValue has the value to pass to
  647.                  * sprintf, according to the following
  648.                  * definitions: */
  649. #   define INT_VALUE 0
  650. #   define PTR_VALUE 1
  651. #   define DOUBLE_VALUE 2
  652.     char *dst = interp->result;    /* Where result is stored.  Starts off at
  653.                  * interp->resultSpace, but may get dynamically
  654.                  * re-allocated if this isn't enough. */
  655.     int dstSize = 0;        /* Number of non-null characters currently
  656.                  * stored at dst. */
  657.     int dstSpace = TCL_RESULT_SIZE;
  658.                 /* Total amount of storage space available
  659.                  * in dst (not including null terminator. */
  660.     int noPercent;        /* Special case for speed:  indicates there's
  661.                  * no field specifier, just a string to copy. */
  662.     int argIndex;        /* Index of argument to substitute next. */
  663.     int gotXpg = 0;        /* Non-zero means that an XPG3 %n$-style
  664.                  * specifier has been seen. */
  665.     int gotSequential = 0;    /* Non-zero means that a regular sequential
  666.                  * (non-XPG3) conversion specifier has been
  667.                  * seen. */
  668.     int useShort;        /* Value to be printed is short (half word). */
  669.     char *end;            /* Used to locate end of numerical fields. */
  670.  
  671.     /*
  672.      * This procedure is a bit nasty.  The goal is to use sprintf to
  673.      * do most of the dirty work.  There are several problems:
  674.      * 1. this procedure can't trust its arguments.
  675.      * 2. we must be able to provide a large enough result area to hold
  676.      *    whatever's generated.  This is hard to estimate.
  677.      * 2. there's no way to move the arguments from argv to the call
  678.      *    to sprintf in a reasonable way.  This is particularly nasty
  679.      *    because some of the arguments may be two-word values (doubles).
  680.      * So, what happens here is to scan the format string one % group
  681.      * at a time, making many individual calls to sprintf.
  682.      */
  683.  
  684.     if (argc < 2) {
  685.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  686.         " formatString ?arg arg ...?\"", (char *) NULL);
  687.     return TCL_ERROR;
  688.     }
  689.     argIndex = 2;
  690.     for (format = argv[1]; *format != 0; ) {
  691.     register char *newPtr = newFormat;
  692.  
  693.     width = precision = noPercent = useShort = 0;
  694.     whichValue = PTR_VALUE;
  695.  
  696.     /*
  697.      * Get rid of any characters before the next field specifier.
  698.      */
  699.  
  700.     if (*format != '%') {
  701.         register char *p;
  702.  
  703.         ptrValue = p = format;
  704.         while ((*format != '%') && (*format != 0)) {
  705.         *p = *format;
  706.         p++;
  707.         format++;
  708.         }
  709.         size = p - ptrValue;
  710.         noPercent = 1;
  711.         goto doField;
  712.     }
  713.  
  714.     if (format[1] == '%') {
  715.         ptrValue = format;
  716.         size = 1;
  717.         noPercent = 1;
  718.         format += 2;
  719.         goto doField;
  720.     }
  721.  
  722.     /*
  723.      * Parse off a field specifier, compute how many characters
  724.      * will be needed to store the result, and substitute for
  725.      * "*" size specifiers.
  726.      */
  727.  
  728.     *newPtr = '%';
  729.     newPtr++;
  730.     format++;
  731.     if (isdigit(UCHAR(*format))) {
  732.         int tmp;
  733.  
  734.         /*
  735.          * Check for an XPG3-style %n$ specification.  Note: there
  736.          * must not be a mixture of XPG3 specs and non-XPG3 specs
  737.          * in the same format string.
  738.          */
  739.  
  740.         tmp = strtoul(format, &end, 10);
  741.         if (*end != '$') {
  742.         goto notXpg;
  743.         }
  744.         format = end+1;
  745.         gotXpg = 1;
  746.         if (gotSequential) {
  747.         goto mixedXPG;
  748.         }
  749.         argIndex = tmp+1;
  750.         if ((argIndex < 2) || (argIndex >= argc)) {
  751.         goto badIndex;
  752.         }
  753.         goto xpgCheckDone;
  754.     }
  755.  
  756.     notXpg:
  757.     gotSequential = 1;
  758.     if (gotXpg) {
  759.         goto mixedXPG;
  760.     }
  761.  
  762.     xpgCheckDone:
  763.     while ((*format == '-') || (*format == '#') || (*format == '0')
  764.         || (*format == ' ') || (*format == '+')) {
  765.         *newPtr = *format;
  766.         newPtr++;
  767.         format++;
  768.     }
  769.     if (isdigit(UCHAR(*format))) {
  770.         width = strtoul(format, &end, 10);
  771.         format = end;
  772.     } else if (*format == '*') {
  773.         if (argIndex >= argc) {
  774.         goto badIndex;
  775.         }
  776.         if (Tcl_GetInt(interp, argv[argIndex], &width) != TCL_OK) {
  777.         goto fmtError;
  778.         }
  779.         argIndex++;
  780.         format++;
  781.     }
  782.     if (width != 0) {
  783.         sprintf(newPtr, "%d", width);
  784.         while (*newPtr != 0) {
  785.         newPtr++;
  786.         }
  787.     }
  788.     if (*format == '.') {
  789.         *newPtr = '.';
  790.         newPtr++;
  791.         format++;
  792.     }
  793.     if (isdigit(UCHAR(*format))) {
  794.         precision = strtoul(format, &end, 10);
  795.         format = end;
  796.     } else if (*format == '*') {
  797.         if (argIndex >= argc) {
  798.         goto badIndex;
  799.         }
  800.         if (Tcl_GetInt(interp, argv[argIndex], &precision) != TCL_OK) {
  801.         goto fmtError;
  802.         }
  803.         argIndex++;
  804.         format++;
  805.     }
  806.     if (precision != 0) {
  807.         sprintf(newPtr, "%d", precision);
  808.         while (*newPtr != 0) {
  809.         newPtr++;
  810.         }
  811.     }
  812.     if (*format == 'l') {
  813.         format++;
  814.     } else if (*format == 'h') {
  815.         useShort = 1;
  816.         *newPtr = 'h';
  817.         newPtr++;
  818.         format++;
  819.     }
  820.     *newPtr = *format;
  821.     newPtr++;
  822.     *newPtr = 0;
  823.     if (argIndex >= argc) {
  824.         goto badIndex;
  825.     }
  826.     switch (*format) {
  827.         case 'i':
  828.         newPtr[-1] = 'd';
  829.         case 'd':
  830.         case 'o':
  831.         case 'u':
  832.         case 'x':
  833.         case 'X':
  834.         if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue)
  835.             != TCL_OK) {
  836.             goto fmtError;
  837.         }
  838.         whichValue = INT_VALUE;
  839.         size = 40;
  840.         break;
  841.         case 's':
  842.         ptrValue = argv[argIndex];
  843.         size = strlen(argv[argIndex]);
  844.         break;
  845.         case 'c':
  846.         if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue)
  847.             != TCL_OK) {
  848.             goto fmtError;
  849.         }
  850.         whichValue = INT_VALUE;
  851.         size = 1;
  852.         break;
  853.         case 'e':
  854.         case 'E':
  855.         case 'f':
  856.         case 'g':
  857.         case 'G':
  858.         if (Tcl_GetDouble(interp, argv[argIndex], &doubleValue)
  859.             != TCL_OK) {
  860.             goto fmtError;
  861.         }
  862.         whichValue = DOUBLE_VALUE;
  863.         size = 320;
  864.         if (precision > 10) {
  865.             size += precision;
  866.         }
  867.         break;
  868.         case 0:
  869.         interp->result =
  870.             "format string ended in middle of field specifier";
  871.         goto fmtError;
  872.         default:
  873.         sprintf(interp->result, "bad field specifier \"%c\"", *format);
  874.         goto fmtError;
  875.     }
  876.     argIndex++;
  877.     format++;
  878.  
  879.     /*
  880.      * Make sure that there's enough space to hold the formatted
  881.      * result, then format it.
  882.      */
  883.  
  884.     doField:
  885.     if (width > size) {
  886.         size = width;
  887.     }
  888.     if ((dstSize + size) > dstSpace) {
  889.         char *newDst;
  890.         int newSpace;
  891.  
  892.         newSpace = 2*(dstSize + size);
  893.         newDst = (char *) ckalloc((unsigned) newSpace+1);
  894.         if (dstSize != 0) {
  895.         memcpy((VOID *) newDst, (VOID *) dst, (size_t) dstSize);
  896.         }
  897.         if (dstSpace != TCL_RESULT_SIZE) {
  898.         ckfree(dst);
  899.         }
  900.         dst = newDst;
  901.         dstSpace = newSpace;
  902.     }
  903.     if (noPercent) {
  904.         memcpy((VOID *) (dst+dstSize), (VOID *) ptrValue, (size_t) size);
  905.         dstSize += size;
  906.         dst[dstSize] = 0;
  907.     } else {
  908.         if (whichValue == DOUBLE_VALUE) {
  909.         sprintf(dst+dstSize, newFormat, doubleValue);
  910.         } else if (whichValue == INT_VALUE) {
  911.         if (useShort) {
  912.             sprintf(dst+dstSize, newFormat, (short) intValue);
  913.         } else {
  914.             sprintf(dst+dstSize, newFormat, intValue);
  915.         }
  916.         } else {
  917.         sprintf(dst+dstSize, newFormat, ptrValue);
  918.         }
  919.         dstSize += strlen(dst+dstSize);
  920.     }
  921.     }
  922.  
  923.     interp->result = dst;
  924.     if (dstSpace != TCL_RESULT_SIZE) {
  925.     interp->freeProc = (Tcl_FreeProc *) free;
  926.     } else {
  927.     interp->freeProc = 0;
  928.     }
  929.     return TCL_OK;
  930.  
  931.     mixedXPG:
  932.     interp->result = "cannot mix \"%\" and \"%n$\" conversion specifiers";
  933.     goto fmtError;
  934.  
  935.     badIndex:
  936.     if (gotXpg) {
  937.     interp->result = "\"%n$\" argument index out of range";
  938.     } else {
  939.     interp->result = "not enough arguments for all format specifiers";
  940.     }
  941.  
  942.     fmtError:
  943.     if (dstSpace != TCL_RESULT_SIZE) {
  944.     ckfree(dst);
  945.     }
  946.     return TCL_ERROR;
  947. }
  948.